home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
p063b9s.zip
/
UNIT
/
ZRECEIVE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1997-03-02
|
26KB
|
787 lines
UNIT ZReceive;
{╔══════════════════════════════════════════════════════════════════════════╗}
{║ ZModem receive Last changed: 02.03.97 SA ║}
{║ ║}
{║ (C) Copyright 1989-97 by ║}
{║ Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager ║}
{║ ║}
{║ This source may not be given to anybody, without the written permission ║}
{║ from The Portal Team. ║}
{╚══════════════════════════════════════════════════════════════════════════╝}
{$I POPDEFS.INC}
INTERFACE
USES Use32, Dos;
FUNCTION ZModemReceive(CONST RcvPath: PathStr; IsWaZoo: Boolean): Integer;
IMPLEMENTATION
USES OpCrt, OpDos, OpDate, OpRoot, OpString, ApTimer,
PoPTypes, Globals, ZMisc, UnixDate, MailUtil, Crc, Com, Util, FileUtil,
TransVid, NetFile, SimpDB, LogFile, MTask, StrUtil;
FUNCTION ZModemReceive;
CONST
ZAttnLen = 33;
VAR
Attn : S34;
OutFile : FILE;
CanDo32,
IsBinary, EOFSeen : Boolean;
i, TryZHdrType, ZConv : Integer;
UploadPath : PathStr;
RxCount, FileStart,
RxBytes, DiskAvail,
RemoteSize,
RemoteTime : LongInt;
buf : Pointer;
RemoteName : String;
ReceiveMax : Word;
t : EventTimer;
PROCEDURE RZAckBibi;
VAR
n : Byte;
c : Integer;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZAckBibi ',1,1,7);
{$ENDIF}
ZPutLongIntoHeader(0, TxHdr);
{ FPurgeIn;}
FOR n:=4 DOWNTO 1 DO
BEGIN
ZSendHexHeader(ZFIN, TxHdr);
CASE ZGetByte(100) OF
79 : BEGIN
c:=ZGetByte(5);
ComPort^.PurgeIn;
Exit;
END;
TimeOut,
RCDO : Exit;
END;
END;
END;
FUNCTION RZSaveToDisk(VAR RxBytes : LongInt) : Integer;
LABEL
Oops;
VAR
RealCount,i : Integer;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZSaveToDisk ',1,1,7);
{$ENDIF}
IF GotESC THEN
BEGIN
ZSendCan;
REPEAT
i:=ZGetByte(20);
ComPort^.PurgeIn;
UNTIL (i=TimeOut) OR (i=RCDO);
ZSendCan;
ShowError('Keyboard ESC',False,true,false);
RZSaveToDisk:=Error;
Exit;
END;
{IF RxBytes<>ZSize THEN WriteLn(ZSize);}
{
IF IsBinary THEN
BEGIN
}
BlockWrite(OutFile, buf^, RxCount, RealCount);
IF RxCount<>RealCount THEN GOTO Oops;
{
END ELSE
BEGIN
ShowError('Text NOT implemented',True,false,false);
END;
}
Inc(RxBytes, RxCount);
ShowBlockSize(RxCount,false);
ShowCurrentByte(RxBytes,false);
RZSaveToDisk:=ok;
Exit;
Oops:
ShowError('Error writing filedata',True,true,false);
RZSaveToDisk:=Error;
END;
FUNCTION RZGetHeader : Integer;
VAR
Net, Node, IORes : Integer;
Found : Boolean;
OurName : PathStr;
p,n : Byte;
s : String;
Srec : SEARCHREC;
ud, power : LongInt;
Dt : DateTime;
BadWaZOOFile : PSimpDB;
BadWaZooRec : TBadWaZOO;
{$IFDEF DateDebug}
FName : PathStr;
f : File;
{$ENDIF}
BEGIN
{$IFDEF ZDebug}
FastWrite('RZGetHeader ',1,1,7);
{$ENDIF}
{ IF (Not RXBINARY) and (ZConv=ZCNL) THEN IsBinary:=False ELSE IsBinary:=True;}
IsBinary:=True;
RemoteSize:=0;
RemoteTime:=0;
RemoteName:='';
p:=0;
WHILE (p<RxCount) AND (BufAry(Buf^)[p]<>0) DO
BEGIN
RemoteName:=RemoteName+Char(BufAry(Buf^)[p]);
Inc(p);
END;
Inc(p);
RemoteName:=StUpCase(JustFileName(RemoteName));
Replace(RemoteName, ' ', '_', 0);
OurName:=RemoteName;
WHILE (p<RxCount) AND (Char(BufAry(Buf^)[p])<>' ') AND (BufAry(Buf^)[p]<>0) DO
BEGIN
RemoteSize:=(RemoteSize * 10)+BufAry(Buf^)[p] - $30;
Inc(p);
END;
IF RemoteSize+10240>DiskAvail THEN
BEGIN
ShowError('Disk space',True,true,false);
RZGetHeader:=Error;
Exit;
END;
Inc(p);
s:='';
WHILE (p<RxCount) AND (BufAry(Buf^)[p] IN [$30..$37]) DO
BEGIN
s:=s+Char(BufAry(Buf^)[p]);
Inc(p);
END;
ud:=0;
power:=1;
FOR n:=Length(s) DOWNTO 1 DO
BEGIN
ud:=ud+(Ord(s[n])-$30)*power;
power:=power*8;
END;
{$IFDEF DateDebug}
FName:=StartPath+ForceExtension(RemoteName, 'DMP');
if ud>788400000 then addlog('!', 'DATE ERROR: '+FName);
assign(f, fname); rewrite(f, 1);
blockwrite(f, buf^, RxCount);
close(f);
{$ENDIF}
WITH Dt DO
UnpackUnix(ud, Year, Month, Day, Hour, Min, Sec);
packtime(Dt, RemoteTime);
Found:=False;
IF IsWaZoo THEN
BEGIN
IF (Copy(RemoteName,9,4)='.REQ') And (Str2Int('$'+Copy(RemoteName,1,4),Net)) And
(Str2Int('$'+Copy(RemoteName,5,4),Node)) THEN
BEGIN
RemoteName:=JustFileName(MakeReqFileName(Net, Node, GlobNodeStat));
OurName:=RemoteName;
END ELSE
BEGIN
New(BadWaZOOFile, Open(StartPath+PoPBadWaZooFileName, SizeOf(TBadWaZoo), False));
IF BadWaZOOFile<>Nil THEN
BEGIN
WHILE NOT Found AND BadWaZOOFile^.NextRec(BadWaZOORec, Keep) DO
BEGIN
IF CmpAdr(BadWaZooRec.Address, Call) AND
(StUpCase(BadWaZooRec.FName)=StUpCase(RemoteName)) THEN
Found:=True
ELSE
BadWaZooFile^.Unlock(BadWaZooFile^.FilePos-1);
END;
IF Found THEN
BEGIN
BadWaZooFile^.DelRec(BadWaZooRec, BadWaZOOFile^.FilePos-1);
END;
Dispose(BadWaZOOFile, Close);
Found:=((Found) AND (BadWaZooRec.FSize=RemoteSize) AND (BadWaZooRec.FTime=RemoteTime))
END;
IF Found THEN
BEGIN
RenameFile(UploadPath+BadWaZooRec.NewName, UploadPath+RemoteName);
END ELSE
BEGIN
FINDFIRST(UploadPath+RemoteName, AnyFile, Srec);
IF DOSError=0 THEN
BEGIN
IF (SRec.Size=RemoteSize) AND (RemoteTime=SRec.Time) THEN
BEGIN
ShowError('Already have: '+RemoteName+', skipping', False, True, False);
RZGetHeader:=ZSKIP;
FindClose(SRec);
Exit;
END;
RemoteName:=JustFileName(UniqueName(UploadPath+RemoteName));
END;
FindClose(SRec);
END;
END;
END ELSE
BEGIN
FindFirst(UploadPath+RemoteName,AnyFile,SRec);
IF (DosError=0) And ((SRec.Size>RemoteSize) or (SRec.Time<>RemoteTime)) THEN
RemoteName:=JustFileName(UniqueName(UploadPath+RemoteName));
FindClose(SRec);
END;
IF OurName<>RemoteName THEN ShowError('File renamed from: '+OurName+' to: '+RemoteName, False, True, False);
Assign(OutFile, UploadPath+RemoteName); FileMode:=ShareRW+ShareDenyRW;
Reset(OutFile, 1);
IORes:=IoResult;
IF IoRes<>0 THEN Rewrite(OutFile, 1);
IORes:=IoResult;
IF IoRes<>0 THEN
BEGIN
ShowError('Error ('+Long2Str(IoRes)+') creating file: '+UploadPath+RemoteName,True,true,false);
RZGetHeader:=Error;
Exit;
END;
{ Check for TTY }
FileStart:=FileSize(OutFile);
Seek(OutFile, FileStart);
ShowCurrentFileName(RemoteName,FileStart,RemoteSize,96,false);
RZGetHeader:=ok;
END;
FUNCTION RZ32ReceiveData(buf : Pointer; MaxLength : Word) : Integer;
LABEL
CrcFoo;
VAR
Crc32 : LongInt;
d, c : Integer;
x : Byte;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZ32ReceiveData ',1,1,7);
{$ENDIF}
Crc32:=$ffffffff; RxCount:=0;
WHILE RxCount <= MaxLength DO
BEGIN
c:=ZGetZDL;
IF Hi(c)<>0 THEN
BEGIN
CrcFoo:
CASE c OF
GOTCRCE,
GOTCRCG,
GOTCRCQ,
GOTCRCW : BEGIN
d:=c;
Crc32:=UpdCrc32(Lo(c), Crc32);
FOR x:=1 TO 4 DO
BEGIN
c:=ZGetZDL;
IF Hi(c)<>0 THEN GOTO CrcFoo;
Crc32:=UpdCrc32(Lo(c), Crc32);
END;
IF Crc32<>$debb20e3 THEN
BEGIN
ShowError('CRC error ',True,false,false);
Pause(50);
RZ32ReceiveData:=Error;
Exit;
END;
RZ32ReceiveData:=d;
END;
GOTCAN : BEGIN
ShowError('Cancelled',False,true,false);
RZ32ReceiveData:=ZCAN;
END;
TimeOut : BEGIN
ShowError('TimeOut1',True,false,false);
RZ32ReceiveData:=c;
END;
RCDO : BEGIN
ShowError('Lost Carrier',True,false,false);
ComPort^.PurgeIn;
RZ32ReceiveData:=c;
END;
ELSE BEGIN
ShowError('Debris ['+HexW(Word(c))+']',True,false,false);
ComPort^.PurgeIn;
RZ32ReceiveData:=c;
END;
END;
Exit;
END;
BufAry(Buf^)[RxCount]:=Lo(c);
Inc(RxCount);
Crc32:=UpdCrc32(Lo(c), Crc32);
END;
ShowError('Long pkt',True,false,false);
RZ32ReceiveData:=Error;
END;
FUNCTION RZReceiveData(buf : Pointer; MaxLength : Word) : Integer;
LABEL
CrcFoo;
VAR
c, d : Integer;
Crc16 : Word;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZReceiveData ',1,1,7);
{$ENDIF}
IF RxFrameInd=ZBIN32 THEN
BEGIN
CanDo32:=True;
ShowErrorCheckingMethod('Z-Receive CRC32',false);
RZReceiveData:=RZ32ReceiveData(buf, MaxLength);
Exit;
END;
CanDo32:=False;
ShowErrorCheckingMethod('Z-Receive CRC16',false);
Crc16:=0; RxCount:=0;
WHILE RxCount <= MaxLength DO
BEGIN
c:=ZGetZDL;
IF Hi(c)<>0 THEN
BEGIN
CrcFoo:
CASE c OF
GOTCRCE,
GOTCRCG,
GOTCRCQ,
GOTCRCW : BEGIN
d:=c;
Crc16:=UpdCrc16(Lo(c), Crc16);
c:=ZGetZDL;
IF Hi(c)>0 THEN GOTO CrcFoo;
Crc16:=UpdCrc16(Lo(c), Crc16);
c:=ZGetZDL;
IF Hi(c)>0 THEN GOTO CrcFoo;
Crc16:=UpdCrc16(Lo(c), Crc16);
IF Crc16<>0 THEN
BEGIN
ShowError('CRC Error',True,false,false);
RZReceiveData:=Error;
Exit;
END;
RZReceiveData:=d;
END;
GOTCAN : BEGIN
ShowError('Cancelled',False,false,false);
RZReceiveData:=ZCAN;
END;
TimeOut : BEGIN
ShowError('TimeOut2',True,false,false);
RZReceiveData:=c;
END;
RCDO : BEGIN
ShowError('No Carrier',True,true,false);
ComPort^.PurgeIn;
RZReceiveData:=c;
END;
ELSE BEGIN
ShowError('Debris ['+HexW(Word(c))+']',True,false,false);
ComPort^.PurgeIn;
RZReceiveData:=c;
END;
END; { case }
Exit;
END;
BufAry(Buf^)[RxCount]:=Byte(c);
Inc(RxCount);
Crc16:=UpdCrc16(Lo(c), Crc16);
END;
ShowError('Long pkt',True,false,false);
RZReceiveData:=Error;
END;
FUNCTION RZReceiveFile : Integer;
LABEL
Cont, NxtHdr, MoreData, Err;
VAR
c, n : Integer;
SPtr : String;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZeceiveFile ',1,1,7);
{$ENDIF}
EOFSeen:=False;
c:=RZGetHeader;
IF (c=Error) OR (c=ZSKIP) THEN
BEGIN
IF c=ZSKIP THEN TryZHdrType:=ZSKIP;
RZReceiveFile:=c;
Exit;
END;
n:=10;
RxBytes:=FileStart;
WHILE True DO
BEGIN
Cont:
ZPutLongIntoHeader(RxBytes, TxHdr);
ZSendHexHeader(ZRPOS, TxHdr);
NxtHdr:
c:=ZGetHeader(RxHdr);
CASE c OF
ZDATA : BEGIN
IF RxPos<>RxBytes THEN
BEGIN
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='FuBar';
GOTO Err;
END;
ShowError('Bad pos: '+Long2Str(RxBytes)+' '+Long2Str(RxPos),True,false,false);
ZPutString(Attn);
GOTO Cont;
END;
MoreData:
c:=RZReceiveData(buf, ReceiveMax);
CASE c OF
ZCAN : BEGIN
SPtr:='Cancelled';
GOTO Err;
END;
RCDO : BEGIN
SPtr:='Carrier';
ComPort^.PurgeIn;
GOTO Err;
END;
Error : BEGIN
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='FUBAR';
GOTO Err;
END;
ShowError('Pos Error: '+Long2Str(RxBytes)+' Retries: '+Long2Str(n),True,false,false);
ZPutString(Attn);
{continue}
END;
TimeOut : BEGIN
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='TimeOut3';
GOTO Err;
END;
ShowError('TimeOut at: '+Long2Str(RxBytes)+' Retries: '+Long2Str(n),True,false,false);
END;
GOTCRCW,
GOTCRCQ : BEGIN
n:=10;
IF RZSaveToDisk(RxBytes)=Error THEN
BEGIN
RZReceiveFile:=Error;
Exit;
END;
ZPutLongIntoHeader(RxBytes, TxHdr);
ZSendHexHeader(ZACK, TxHdr);
IF c=GOTCRCQ THEN GOTO MoreData
ELSE GOTO NxtHdr;
END;
GOTCRCG,
GOTCRCE : BEGIN
n:=10;
IF RZSaveToDisk(RxBytes)=Error THEN
BEGIN
RZReceiveFile:=Error;
Exit;
END;
IF c=GOTCRCE THEN GOTO NxtHdr
ELSE GOTO MoreData;
END;
END; { case }
END; { case zdata}
ZNAK,
TimeOut : BEGIN
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='Garbled packet';
GOTO Err;
END;
ShowError('TimeOut at: '+Long2Str(RxBytes)+' Retries: '+Long2Str(n),True,false,false);
END;
ZFILE : BEGIN
c:=RZReceiveData(buf, ReceiveMax);
END;
ZEOF : BEGIN
IF RxPos<>RxBytes THEN GOTO NxtHdr;
SetFTime(OutFile, RemoteTime);
Close(OutFile);
IF IoResult<>0 THEN ShowError('Error closing file',True,true,false);
FileReceived(RemoteName,'Z'+CrcStr(CanDo32),FALSE);
RZReceiveFile:=c;
Exit;
END;
Error : BEGIN
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='HdrJunk';
GOTO Err;
END;
ShowError('Pos Error: '+Long2Str(RxBytes)+' Retries: '+Long2Str(n),True,false,false);
ZPutString(Attn);
END;
ZSKIP : BEGIN
RZReceiveFile:=c;
Exit;
END;
ELSE BEGIN
SPtr:='Que WHAT??!';
ComPort^.PurgeIn;
GOTO Err;
END;
END; {case}
END; { while }
Err:
ShowError('Z-rz '+SPtr,True,true,false);
RZReceiveFile:=Error;
END;
FUNCTION RZInitReceiver : Integer;
LABEL
Again, Err;
VAR
n, errors : ShortInt;
SPtr : String;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZInitReceiver ',1,1,7);
{$ENDIF}
n:=12;
errors:=0;
FillChar(Attn, SizeOf(Attn), 0);
WHILE n >= 0 DO
BEGIN
Again:
ZPutLongIntoHeader(0, TxHdr);
TxHdr[ZF0]:=CANFC32 OR CANFDX OR CANOVIO;
ZSendHexHeader(TryZHdrType, TxHdr);
IF (TryZHdrType=ZSKIP) THEN TryZHdrType:=ZRINIT;
CASE ZGetHeader(RxHdr) OF
ZFILE : BEGIN
ZConv:=RxHdr[ZF0];
TryZHdrType:=ZRINIT;
IF RZReceiveData(buf, ReceiveMax)=GOTCRCW THEN
BEGIN
RZInitReceiver:=ZFILE;
Exit;
END;
ZSendHexHeader(ZNAK, TxHdr);
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='ZFILE';
GOTO Err;
END;
GOTO Again;
END;
ZSINIT : BEGIN
IF RZReceiveData(@Attn[1], ZAttnLen)=GOTCRCW THEN
BEGIN
ZPutLongIntoHeader(0, TxHdr);
ZSendHexHeader(ZACK, TxHdr);
Exit;
END;
i:=1;
WHILE (Attn[i]<>#0) And (i<255) DO
Inc(i);
Attn[0]:=Char(i-1);
ZSendHexHeader(ZNAK, TxHdr);
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='ZSINIT';
GOTO Err;
END;
GOTO Again;
END;
ZFREECNT : BEGIN
ZPutLongIntoHeader(DiskAvail, TxHdr);
ZSendHexHeader(ZACK, TxHdr);
GOTO Again;
END;
ZCOMMAND : BEGIN
IF RZReceiveData(buf, ReceiveMax)=GOTCRCW THEN
BEGIN
ShowError('Ignoring ?? ',False,false,false);
ZPutLongIntoHeader(0, TxHdr);
REPEAT
ZSendHexHeader(ZCOMPL, TxHdr);
Inc(errors);
UNTIL (errors >= 10) OR (ZGetHeader(RxHdr)=ZFIN);
RZAckBibi;
RZInitReceiver:=ZCOMPL;
Exit;
END ELSE
ZSendHexHeader(ZNAK, TxHdr);
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='CMD';
GOTO Err;
END;
GOTO Again;
END;
ZCOMPL : BEGIN
Dec(n);
IF n=0 THEN
BEGIN
SPtr:='COMPL';
GOTO Err;
END;
GOTO Again;
END;
ZFIN : BEGIN
RZAckBibi;
RZInitReceiver:=ZCOMPL;
Exit;
END;
ZCAN : BEGIN
SPtr:='CAN';
GOTO Err;
END;
RCDO : BEGIN
SPtr:='CARRIER';
ComPort^.PurgeIn;
GOTO Err;
END;
END; {case}
Dec(n);
END; { while }
SPtr:='TIME';
Err:
ShowError('Z-InitRecv '+SPtr,True,true,false);
RZInitReceiver:=Error;
END;
FUNCTION RZReceiveBatch : Integer;
VAR
UName : PathStr;
c : Integer;
Found : Boolean;
BadWaZOOFile : PSimpDB;
BadWaZooRec : TBadWaZOO;
BEGIN
{$IFDEF ZDebug}
FastWrite('RZReceiveBatch ',1,1,7);
{$ENDIF}
WHILE True DO
BEGIN
c:=RZReceiveFile;
CASE c OF
ZEOF,
ZSKIP : BEGIN
CASE RZInitReceiver OF
ZCOMPL : BEGIN
RZReceiveBatch:=ok;
Exit;
END;
ZFILE : ;
ELSE BEGIN
RZReceiveBatch:=Error;
Exit;
END;
END;
END;
ELSE BEGIN
SetFTime(OutFile, RemoteTime);
Found:=(FileSize(OutFile)>0);
Close(OutFile);
IF NOT Found THEN
Erase(OutFile)
ELSE
IF IsWaZoo THEN
BEGIN
AddLog('!','File '+RemoteName+' aborted - saving resume information');
UName:=UniqueName(UploadPath+'BADWAZOO.000');
RenameFile(UploadPath+RemoteName, UName);
New(BadWaZOOFile, Open(StartPath+PoPBadWaZooFileName, SizeOf(TBadWaZoo), True));
IF BadWaZooFile<>NIL THEN
BEGIN
FillChar(BadWaZooRec, SizeOf(BadWaZooRec), 0);
WITH BadWaZooRec DO
BEGIN
Address:=Call;
FName:=RemoteName;
FSize:=RemoteSize;
FTime:=RemoteTime;
NewName:=StUpCase(JustFileName(UName));
NodeStat:=GlobNodeStat;
END;
BadWaZooFile^.AddRec(BadWazooRec);
Dispose(BadWaZooFile, Close);
END ELSE
AddLog('!', 'Not enough memory to open: '+PoPBadWaZooFileName+' resume information NOT saved');
END;
RZReceiveBatch:=c;
Exit;
END;
END; { case }
END; { while }
END;
BEGIN
{$IFDEF ZDebug}
FastWrite('ZModemReceive ',1,1,7);
{$ENDIF}
{ FSetBrk(Off);
FSetBrk(On);}
ReceiveMax:=32768;
RxTimeOut:=100;
TryZHdrType:=ZRINIT;
UploadPath:=RcvPath;
UploadPath:=AddBackSlash(UploadPath);
DiskAvail:=DriveFree(Ord(Upcase(RcvPath[1])) - Ord('A')+1);
IF NOT GetMemCheck(buf, 8192) THEN
BEGIN
ShowError('Not enough memory',True,true,false);
ZModemReceive:=Error;
Exit;
END;
FillChar(buf^, 8192, 0);
ComPort^.PurgeIn; ComPort^.PurgeOut;
i:=RZInitReceiver;
IF (i=ZCOMPL) OR ((i=ZFILE) AND (RZReceiveBatch=ok)) THEN
BEGIN
{ FSetBrk(Off);
FSetBrk(On);}
FreeMem(buf, 8192);
ZModemReceive:=ZTRUE;
ShowError('Transfer completed', False, False, False);
Exit;
END;
ShowError('Transfer aborted', False, True, False);
ComPort^.PurgeOut;
ComPort^.SetXOn(Off);
ZSendCan;
NewTimerSecs(t, 2);
WHILE (NOT TimerExpired(t)) AND (NOT ComPort^.OutEmpty) AND (ComPort^.Carrier) DO
GiveUpTime;
{ FSetBrk(On);}
FreeMem(buf, 8192);
ZModemReceive:=ZFALSE;
END;
END.